FAIRE DES CARTES DE FLUX DANS R

Lorem Ipsum is simply dummy text of the printing and typesetting industry. Lorem Ipsum has been the industry’s standard dummy text ever since the 1500s, when an unknown printer took a galley of type and scrambled it to make a type specimen book. It has survived not only five centuries, but also the leap into electronic typesetting, remaining essentially unchanged. It was popularised in the 1960s with the release of Letraset sheets containing Lorem Ipsum passages, and more recently with desktop publishing software like Aldus PageMaker including versions of Lorem Ipsum.

Les données

Jeu de données sur les migrations internationales. Migration Stock at subregional level, 2019 Source : United Nations, Department of Economic and Social Affairs, Population Division (2019). Voir

Les packages

install.packages("sf")
install.packages("remotes")
library(remotes)
install_github("riatelab/mapsf")
install_github("tributetotobler/ttt")
library("sf")
library("mapsf")
library("ttt")

Import et mise en forme des données

countries <- st_read("data/world/geom/countries.gpkg")
subregions <- st_read("data/world/geom/subregions.gpkg")
graticule <- st_read("data/world/geom/graticule.gpkg")
bbox <- st_read("data/world/geom/bbox.gpkg")
migr <- read.csv("data/world/fij/migr2019_T.csv")

crs <- "+proj=aeqd +lat_0=90 +lon_0=50 +x_0=0 +y_0=0 +datum=WGS84 +units=m +no_defs "
countries <- st_transform(x = countries, crs = crs)
subregions <- st_transform(x = subregions, crs = crs)
graticule <- st_transform(x = graticule, crs = crs)
bbox <- st_transform(x = bbox, crs = crs)
land <- st_union(countries)

Template cartographique

col = "#ffc524"
credit = paste0("Françoise Bahoken & Nicolas Lambert, 2021\n",
                  "Source: United Nations, Department of Economic\n",
                  "and Social Affairs, Population Division (2019)")
# theme = mf_theme(x = "default", bg = "white", tab = FALSE, 
#                    pos = "center", line = 2, inner = FALSE, 
#                    fg = "#9F204270", mar = c(0,0, 2, 0),cex = 1.9)

theme <- mf_theme(
  x = "default",
  bg = "#3b3b3b", 
  fg = "#ffc524", 
  mar = c(0,0, 2, 0),
  tab = TRUE,
  pos = "left", 
  inner = TRUE, 
  line = 2, 
  cex = 1.9, 
  font = 3
  )

template = function(title, file){

  mf_export(
    countries,
    export = "png",
    width = 1000,
    filename = file,
    res = 96,
    theme = theme, 
    expandBB = c(-.02,0,-.02,0)
  )
  mf_map(bbox, col = "#3b3b3b",border = NA, lwd = 0.5, add = TRUE)
  mf_map(graticule, col = "#FFFFFF50", lwd = 0.5, add = TRUE)
  mf_map(countries, col = "#4e4f4f",border = "#3b3b3b", lwd = 0.5, add = TRUE)
    # mf_map(links, col = NA,border = "#317691", lwd = 0.5, add = TRUE)
  mf_credits(
    txt = credit,
    pos = "bottomright",
    col = "#1a2640",
    cex = 0.7,
    font = 3,
    bg = "#ffffff30"
  )
  mf_title(title)
}
template("Template cartographique", "maps/template.png")
dev.off()

L’effet Spaghetti

links <- mf_get_links(x = countries, df = migr, x_id = "adm0_a3_is", df_id = c("i", "j"))
template("L'effet Spaghetti ", "maps/spaghetti.png")
mf_map(links, col = col, add=TRUE)
mf_map(land, col = NA, border = "#3b3b3b", add=TRUE)
dev.off()

Répondre à des questions simples

knitr::kable(migr[c(0:10),], row.names = F, digits = 1)
i j fij
PAK AFG 106528
TJK AFG 4596
UZB AFG 229
CAN ALB 856
GRC ALB 29852
ITA ALB 8405
MKD ALB 504
TUR ALB 1852
USA ALB 2242
FRA DZA 551

Question 1 : Combien y a t-il de migrants dans le monde en 2019 ?

paste0(sum(migr$fij) / 1000000, " millions")
## [1] "260.283744 millions"

Question 2 : …

Prendre le prisme d’un seul pays

Origine des migrants vivant en Afrique du Sud

Choix d’un pays

ISO3 <- "FRA"
label = "France"

Jointure et mise ne forme des données

countr <- countries[,c("adm0_a3_is","label")]
migr <- migr[migr$j == ISO3,]
tot <- sum(migr$fij)
migr <- rbind.data.frame(migr, c(i = ISO3,j = ISO3,fij = tot))
migr$fij <- as.numeric(migr$fij)
countr <- merge(x = countr,y = migr, by.x = "adm0_a3_is", by.y = "i", all.x = TRUE)
countr <- countr[-3]
colnames(countr) <- c("id","label","fij","geometry")
knitr::kable(countr[c(0:10),], row.names = F, digits = 1)
id label fij geometry
ABW Aruba 11 MULTIPOLYGON (((-7476945 42…
AFG Afghanistan 6887 MULTIPOLYGON (((2474775 -53…
AGO Angola 23438 MULTIPOLYGON (((-4917506 -1…
AIA Anguilla 10 MULTIPOLYGON (((-7351488 31…
ALB Albania 7371 MULTIPOLYGON (((-2639654 -4…
AND Andorra 1079 MULTIPOLYGON (((-3952645 -3…
ARE United Arab Emirates 862 MULTIPOLYGON (((785851 -712…
ARG Argentina 14253 MULTIPOLYGON (((-14113355 7…
ARM Armenia 21012 MULTIPOLYGON (((-348529.3 -…
ASM American Samoa 1 MULTIPOLYGON (((7561304 878…

Une premiere carte simple

template(paste0("Origine des personnes migrantes vivant en ",label," en 2019"), "maps/prop1.png")
#mf_map(countr[countr$id == ISO3,], col = col, border = "red", lwd = 2, add = TRUE)
mf_map(countr[countr$id != ISO3,], var = "fij", col = col, border = "white", type = "prop",
       inches = 0.3, leg_title_cex = 1.2, leg_val_cex   = 0.8, leg_pos = "bottomleft",
       leg_title = "Nombre de personnes")
mf_map(countr[countr$id == ISO3,], col = NA, border = "#e36019", lwd = 2, add = TRUE)
dev.off()

Même information avec des lignes

countr$dist = ISO3
links <- mf_get_links(x = countr, df = data.frame(countr), x_id = "id", df_id = c("id", "dist"))
links = links[links$id != ISO3,]
template(paste0("Origine des personnes migrantes vivant en ",label," en 2019"), "maps/flows1.png")
mf_map(links, var = "fij", col = col, type = "prop",
       inches = 4, leg_title_cex = 1.2, leg_val_cex   = 0.8,
       leg_title = "Nombre de personnes")
mf_map(countr[countr$id == ISO3,], col = NA, border = "#e36019", lwd = 2, add = TRUE)
dev.off()

Une carte un peu plus sophistiquée

https://analytics.huma-num.fr/Nicolas.Lambert/migrexplorer/

Flowmapper

flowmapper() est une fonction du package ttt (en cours de développement).

library(ttt)

La fonction ttt_flowmapper() prends plusieurs arguements :

Les données

migr <- read.csv("data/world/subregions/migrantstocks2019.csv")
threshold <- 1500
migr <- migr[migr$fij >= threshold,]
knitr::kable(migr[c(0:10),], row.names = F, digits = 1)
i j fij
5500 923 5603
5501 5501 11177
5501 918 5334
5501 920 1666
5501 922 18402
5501 924 2551
906 906 5202
906 918 5700
910 910 5330
910 913 1538
flows <- ttt_flowmapper(
  x = subregions,
  xid = "id",
  df = migr,
  dfid = c("i","j"),
  dfvar = "fij",
  plot = FALSE
)

$inks

template("ttt_flowmapper$links", "maps/ttt_links.png")
mf_map(subregions, col = "#4e4f4f",border = "#3b3b3b", lwd = 0.5, add = TRUE)
mf_map(flows$links, col = col, lwd = 3, add = TRUE)
dev.off()

$circles

template("ttt_flowmapper$circles", "maps/ttt_circles.png")
mf_map(subregions, col = "#4e4f4f",border = "#3b3b3b", lwd = 0.5, add = TRUE)
mf_map(flows$circles, col = col, add = TRUE)
dev.off()

$fleches

template("ttt_flowmapper$flows", "maps/ttt_flows.png")
mf_map(subregions, col = "#4e4f4f",border = "#3b3b3b", lwd = 0.5, add = TRUE)
mf_map(flows$flows, col = col, add = TRUE)
dev.off()

Visualisation par défaut

template("ttt_flowmapper$flows", "maps/ttt_flows.png")
mf_map(subregions, col = "#4e4f4f",border = "#3b3b3b", lwd = 0.5, add = TRUE)
ttt_flowmapper(
 x = subregions,
 xid = "id",
type = "arrows",
 df = migr,
 dfid = c("i","j"),
 dfvar = "fij", 
 col = col,
 border = "#424242",
  border2 = col,
add=TRUE
)
dev.off()

La VV taille, c’est aussi la surface

template("La surface des fleches", "maps/ttt_surface.png")
mf_map(subregions, col = "#4e4f4f",border = "#3b3b3b", lwd = 0.5, add = TRUE)
ttt_flowmapper(
 x = subregions,
 xid = "id",
type = "arrows",
size = "area",
 df = migr,
 dfid = c("i","j"),
 dfvar = "fij", 
 col = col,
 border = "#424242",
  border2 = col,
add=TRUE
)
dev.off()

Epaisseur vs Surface

Interactions (type = “rect”)

migr2 <- data.frame(i = integer(),j= integer(),fij = integer())

for (k in 1:length(migr$i)){
  val1 <- migr$fij[k]
  val2 <- migr[migr$i == migr$j[k] & migr$j == migr$i[k],"fij"]
  val <- sum(val1,val2)
  idi =  migr$i[k]
  idj =  migr$j[k]  
  test <- length(migr2[(migr2$i == idi & migr2$j == idj) | (migr2$i == idj & migr2$j == idi),"fij"])
  if  (test == 0){migr2 <- rbind(migr2, data.frame(i = idi, j = idj, fij = val))}
}
migr2 <- migr2[migr2$i != migr2$j,] 
head(migr2)
##      i   j   fij
## 1 5500 923  9999
## 3 5501 918  5334
## 4 5501 920  3221
## 5 5501 922 18402
## 6 5501 924  2551
## 8  906 918  5700
template("tInteractions", "maps/ttt_interactions.png")
c <- ttt_flowmapper(
 x = subregions,
 xid = "id",
 size = "thickness",
 type = "rect",
 df = migr2,
 dfid = c("i","j"),
 dfvar = "fij",
 col = col,
border = "#424242",
  border2 = col,
 add=TRUE
)
dev.off()

Combiner flux intra et flux inter

intra <- migr[migr$i == migr$j,]
intra <- intra[,c("i","fij")]
colnames(intra) <- c("id","nb")
knitr::kable(intra, row.names = F, digits = 1)
template("Flux inter et flux intra", "maps/interintra.png")
flows <- ttt_flowmapper(
 x = subregions,
 xid = "id",
 df = migr,
 dfid = c("i","j"),
 dfvar = "fij",
 size = "thickness",
 type = "arrows",
 decreasing = FALSE,
 add = TRUE,
 lwd = 1,
 col = col,
 border = "#424242",
 k = NULL,
 k2 = 60,
 df2 = intra,
 df2id = "id",
 df2var = "nb",
 col2 = col,
 border2 = "#424242"
)
dev.off()